C cfortex.f
C Burkhard Burow, burow@vxdesy.cern.ch, University of Toronto, 1992. 

C NAG f90 only
C Uses an exclamation mark, '!', to start comments. Do:
C prompt> mv cfortex.f cf_temp.f &&sed 's/^C/\!/g' cf_temp.f >cfortex.f
C      to convert the comments here into f90 compliant ones.
C NAG f90 only

      subroutine ss1(b)
      character*(*) b
      character*(13) a
      data a/'first'/
      b = a
      return
      end

      subroutine abc(a,b,c)
      character*(*) b,a,c
      character*(13) d
      d = a
      a = b
      b = c
      c = d
      return
      end

      subroutine forstr1(b)
      character*(*) b
      character*(13) a
      character*(13) forstr
      data a/'firs'/
      b = forstr(a)
      return
      end


      subroutine EASY(a,b)
      integer a,b
      a = b
      return
      end

      character*(*) function forstr(a)
      character*(*) a
      forstr = a
      return
      end

      function rr(i)
      rr = i
      return
      end

      character*(*) function forstr2()
C      character*(13) a   VAX/Ultrix complains about these ().
      character*13 a
      data a/'first'/
      forstr2 = a
      return
      end

      character*(*) function ft(v, w, a)
      character *(*) v(4), w(4)
      print*,'FT:len(v(1 or 2 or 3 or 4))  =',len(v(1))
      print*,'FT:len(w(1 or 2 or 3))    =',len(w(1))
      print*,'FT:a = ',a
      print*,'FT:v(1,2,3,4) =',v(1),',',v(2),',',v(3),',',v(4)
      print*,'FT:w(1,2,3,4) =',w(1),',',w(2),',',w(3),',',w(4)
      ft = v(1)
      return
      end

      character*(*) function fz(v, w, i)
      character *(*) v(i), w(i)
      print*,'FZ:len(v(1 or 2 or 3 or 4))  =',len(v(1))
      print*,'FZ:len(w(1 or 2 or 3))    =',len(w(1))
      do 100 j = 1,i
        print*,'FZ:v(',j,') =',v(j),'   w(',j,') =',w(j)
100   continue
      fz = v(1)
      return
      end

      subroutine sz(v, w, i)
      character *(*) v(i), w(i)
      print*,'SZ:len(v(1 or 2 or 3 or 4))  =',len(v(1))
      print*,'SZ:len(w(1 or 2 or 3))    =',len(w(1))
      do 100 j = 1,i
        print*,'SZ:v(',j,') =',v(j),'   w(',j,') =',w(j)
100   continue
      return
      end

      subroutine subt(v, w, a)
      character *(*) v(4), w(4)
      print*,'SUBT:len(v(1 or 2 or 3 or 4))  =',len(v(1))
      print*,'SUBT:len(w(1 or 2 or 3))    =',len(w(1))
      print*,'SUBT:a = ',a
      print*,'SUBT:v(1,2,3,4) =',v(1),',',v(2),',',v(3),',',v(4)
      print*,'SUBT:w(1,2,3,4) =',w(1),',',w(2),',',w(3),',',w(4)
      return
      end

      subroutine rev(a)
      integer a(2),t
      t    = a(1)
      a(1) = a(2)
      a(2) = t
      return
      end

      integer function frev(a)
      integer a(2)
      frev = a(1)
      a(1) = a(2)
      a(2) = frev
      return
      end

      subroutine ffcb()
      common /fcb/  v,w,x
      character *(13) v, w(4), x(3,2)
      print*,'FFCB:v =',v,'.'
      print*,'FFCB:w(1,2,3,4) =',w(1),',',w(2),',',w(3),',',w(4),'.'
      print*,'FFCB:x([1,2,3],1) =',x(1,1),',',x(2,1),',',x(3,1),'.'
      print*,'FFCB:x([1,2,3],2) =',x(1,2),',',x(2,2),',',x(3,2),'.'
      v      = 'fcb v'
      w(1)   = 'fcb w(1)'
      w(2)   = 'fcb w(2)'
      w(3)   = 'fcb w(3)'
      x(1,1) = 'fcb x(1,1)'
      x(2,1) = 'fcb x(2,1)'
      x(3,1) = 'fcb x(3,1)'
      x(1,2) = 'fcb x(1,2)'
      x(2,2) = 'fcb x(2,2)'
      x(3,2) = 'fcb x(3,2)'
      end

      subroutine feq()
      parameter (kwbank=690)  
C The & in the next line is for f90 line continuation.
C It is in column 74, i.e. part of f77 comments.
      common/gcbank/nzebra,gversn,zversn,ixstor,ixdiv,ixcons,fendq(16)   &
     &             ,lmain,lr1,ws(kwbank)    
      dimension iq(2),q(2),lq(80),iws(2)  
      equivalence (q(1),iq(1),lq(9)),(lq(1),lmain) ,(iws(1),ws(1))
      nzebra     = 1
      gversn     = 2
      zversn     = 3
      ixstor     = 4
      ixcons     = 5
      fendq(16)  = 6
      lmain      = 7
      lr1        = 8
      ws(kwbank) = 9
      lq(9)      = 10
      end

      subroutine fexist()
      print*,'FEXIST: was called'
      call exist()
      return
      end

      subroutine fa(i)
      integer i
      print*,'FA: integer argument =',i
      call cfortranca(i)
      return
      end

      subroutine fb(i)
      integer i
      print*,'FB: integer argument =',i
      i = i*2
      call cfcb(i)
      return
      end

      subroutine fc(b)
      character*(*) b
      print*,'FC: string argument =',b
      call cfcc(b)
      return
      end

      subroutine fd(b)
      character*(*) b
      character*(13) a
      data a/'birthday'/
      b = a
      call cdcfort(b)
      return
      end

      subroutine fe(v)
      character*(*) v(4)
      print*,'FE:len(v(1 or 2 or 3 or 4))  =',len(v(1))
      print*,'FE:v(1,2,3,4) =',v(1),',',v(2),',',v(3),',',v(4)
      call ce(v)
      return
      end

      subroutine ff(v,n)
      character*(*) v(4)
      print*,'FF:len(v(1 or 2 or 3 or 4))  =',len(v(1))
      print*,'FF:v(1,2,3,4) =',v(1),',',v(2),',',v(3),',',v(4)
      print*,'FF:n =',n
      call ccff(v,n)
      return
      end

      integer function fg()
      integer ccg
      fg = ccg()
      return
      end

      character*(*) function fh()
      character*200 cch
      fh = cch()
      return
      end

      character*(*) function fi(v)
      character*(*) v(6)
      character*200 ci
      fi = ci(v)
      return
      end

      character*(*) function fj(v)
      integer v
      character*200 cj
      print*,'FJ:v =',v
      fj = cj(v)
      return
      end

      real function fk()
      real ck
      fk = ck()
      return
      end

      double precision function fl()
      double precision cl
      fl = cl()
      return
      end

      real function fm(r)
      real cm
      fm = cm(r)
      return
      end

      double precision function fn(a,b)
      double precision cn,a,b
      fn = cn(a,b)
      return
      end

      logical function fand(a,b)
      logical cand,a,b
      fand = cand(a,b)
      return
      end


      logical function forr(a,b)
      logical cor,a,b

      print *, 'FORTRAN thinks you called forr(a=',a,',b=',b,').'
      forr = cor(a,b)
      print *, 'FORTRAN thinks cor(a,b) returned with a=',a,',b=',b,').'

      if (a.eqv..true.)then
        print *,'Double check: a is true:',a
      endif
      if (a.eqv..false.)then
        print *,'Double check: a is false:',a
      endif
      if (.not.((a.eqv..false.) .or. (a.eqv..true.))) then
        print *,'Double check: ERROR: a is neither true nor false:',a
        print *,'  Please contact burow@vxdesy.cern.ch.'
      endif

      if (b.eqv..true.)then
        print *,'Double check: b is true:',b
      endif
      if (b.eqv..false.)then
        print *,'Double check: b is false:',b
      endif
      if (.not.((b.eqv..false.) .or. (b.eqv..true.))) then
        print *,'Double check: ERROR: b is neither true nor false:',b
        print *,'  Please contact burow@vxdesy.cern.ch.'
      endif

C      print *, ' '
C      print *, '   Testing non-FORTRAN/77 (b .eq. .true.) which'
C      print *, '    will not compile on NAG f90 or Apollo or IBM RS/6000.'
C      print *, '   Compile cfortest.c with LOGICAL_STRICT defined'
C      print *, '    if you wish this test to work as expected.'
C      print *, '   This test requires a and b to match the internal '
C      print *, '    representation of .TRUE. and .FALSE. exactly.'
C      if (a.eq..true.)then
C        print *,'Representation check: a matches .true.'
C      endif
C      if (a.eq..false.)then
C        print *,'Representation check: a matches .false.'
C      endif
C      if (.not.(a.eq..false. .or. a.eq..true.)) then
C        print *,'Representation check:  '
C        print *,'         a matches neither .true. nor .false.'
C      endif
C      if (b.eq..true.)then
C        print *,'Representation check: b matches .true.'
C      endif
C      if (b.eq..false.)then
C        print *,'Representation check: b matches .false.'
C      endif
C      if (.not.(b.eq..false. .or. b.eq..true.)) then
C        print *,'Representation check:  '
C        print *,'         b matches neither .true. nor .false.'
C      endif
C      print *,' '

      return
      end


      subroutine fstrtok()
      character*70 cstrtok, a

C Setting up a NULL as :  i)  NUL character.
C                         ii) NULL pointer.
      character*4 NULL
      NULL = CHAR(0)//CHAR(0)//CHAR(0)//CHAR(0)

C NUL in a forces cfortran.h to pass a, not a copy as usual.
      data a/'first+second-third+forth-fifth-sixth seventh'/
      a(70:) = NULL

C String until the first '-', then until the first '+'.
      print *,cstrtok(a,    '-')
      print *,cstrtok(NULL, '+')

C Flush the rest of the string.
C Recall cfortran.h kills all trailing blanks. i.e. FORTRAN ' ' -> C "".
      print *,cstrtok(NULL, ' ')

C Further calls return nothing.
      print *,cstrtok(NULL, ' ')

      return
      end
